home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / gnus / gnus-async.el.z / gnus-async.el
Encoding:
Text File  |  1998-05-21  |  10.6 KB  |  318 lines
  1. ;;; gnus-async.el --- asynchronous support for Gnus
  2. ;; Copyright (C) 1996,97 Free Software Foundation, Inc.
  3.  
  4. ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
  5. ;; Keywords: news
  6.  
  7. ;; This file is part of GNU Emacs.
  8.  
  9. ;; GNU Emacs is free software; you can redistribute it and/or modify
  10. ;; it under the terms of the GNU General Public License as published by
  11. ;; the Free Software Foundation; either version 2, or (at your option)
  12. ;; any later version.
  13.  
  14. ;; GNU Emacs is distributed in the hope that it will be useful,
  15. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.     See the
  17. ;; GNU General Public License for more details.
  18.  
  19. ;; You should have received a copy of the GNU General Public License
  20. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22. ;; Boston, MA 02111-1307, USA.
  23.  
  24. ;;; Commentary:
  25.  
  26. ;;; Code:
  27.  
  28. (eval-when-compile (require 'cl))
  29.  
  30. (require 'gnus)
  31. (require 'gnus-sum)
  32. (require 'nntp)
  33.  
  34. (defgroup gnus-asynchronous nil
  35.   "Support for asynchronous operations."
  36.   :group 'gnus)
  37.  
  38. (defcustom gnus-asynchronous t
  39.   "*If nil, inhibit all Gnus asynchronicity.
  40. If non-nil, let the other asynch variables be heeded."
  41.   :group 'gnus-asynchronous
  42.   :type 'boolean)
  43.  
  44. (defcustom gnus-use-article-prefetch 30
  45.   "*If non-nil, prefetch articles in groups that allow this.
  46. If a number, prefetch only that many articles forward;
  47. if t, prefetch as many articles as possible."
  48.   :group 'gnus-asynchronous
  49.   :type '(choice (const :tag "off" nil)
  50.          (const :tag "all" t)
  51.          (integer :tag "some" 0)))
  52.  
  53. (defcustom gnus-prefetched-article-deletion-strategy '(read exit)
  54.   "List of symbols that say when to remove articles from the prefetch buffer.
  55. Possible values in this list are `read', which means that
  56. articles are removed as they are read, and `exit', which means
  57. that all articles belonging to a group are removed on exit
  58. from that group."
  59.   :group 'gnus-asynchronous
  60.   :type '(set (const read) (const exit)))
  61.  
  62. (defcustom gnus-use-header-prefetch nil
  63.   "*If non-nil, prefetch the headers to the next group."
  64.   :group 'gnus-asynchronous
  65.   :type 'boolean)
  66.  
  67. (defcustom gnus-async-prefetch-article-p 'gnus-async-unread-p
  68.   "Function called to say whether an article should be prefetched or not.
  69. The function is called with one parameter -- the article data.
  70. It should return non-nil if the article is to be prefetched."
  71.   :group 'gnus-asynchronous
  72.   :type 'function)
  73.  
  74. ;;; Internal variables.
  75.  
  76. (defvar gnus-async-prefetch-article-buffer " *Async Prefetch Article*")
  77. (defvar gnus-async-article-alist nil)
  78. (defvar gnus-async-article-semaphore '(nil))
  79. (defvar gnus-async-fetch-list nil)
  80.  
  81. (defvar gnus-async-prefetch-headers-buffer " *Async Prefetch Headers*")
  82. (defvar gnus-async-header-prefetched nil)
  83.  
  84. ;;; Utility functions.
  85.  
  86. (defun gnus-group-asynchronous-p (group)
  87.   "Say whether GROUP is fetched from a server that supports asynchronicity."
  88.   (gnus-asynchronous-p (gnus-find-method-for-group group)))
  89.  
  90. ;;; Somewhat bogus semaphores.
  91.  
  92. (defun gnus-async-get-semaphore (semaphore)
  93.   "Wait until SEMAPHORE is released."
  94.   (while (/= (length (nconc (symbol-value semaphore) (list nil))) 2)
  95.     (sleep-for 1)))
  96.  
  97. (defun gnus-async-release-semaphore (semaphore)
  98.   "Release SEMAPHORE."
  99.   (setcdr (symbol-value semaphore) nil))
  100.  
  101. (defmacro gnus-async-with-semaphore (&rest forms)
  102.   `(unwind-protect
  103.        (progn
  104.      (gnus-async-get-semaphore 'gnus-async-article-semaphore)
  105.      ,@forms)
  106.      (gnus-async-release-semaphore 'gnus-async-article-semaphore)))
  107.  
  108. (put 'gnus-asynch-with-semaphore 'lisp-indent-function 0)
  109. (put 'gnus-asynch-with-semaphore 'edebug-form-spec '(body))
  110.  
  111. ;;;
  112. ;;; Article prefetch
  113. ;;;
  114.  
  115. (gnus-add-shutdown 'gnus-async-close 'gnus)
  116. (defun gnus-async-close ()
  117.   (gnus-kill-buffer gnus-async-prefetch-article-buffer)
  118.   (gnus-kill-buffer gnus-async-prefetch-headers-buffer)
  119.   (setq gnus-async-article-alist nil
  120.     gnus-async-header-prefetched nil))
  121.  
  122. (defun gnus-async-set-buffer ()
  123.   (nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t))
  124.  
  125. (defun gnus-async-halt-prefetch ()
  126.   "Stop prefetching."
  127.   (setq gnus-async-fetch-list nil))
  128.  
  129. (defun gnus-async-prefetch-next (group article summary)
  130.   "Possibly prefetch several articles starting with the article after ARTICLE."
  131.   (when (and (gnus-buffer-live-p summary)
  132.          gnus-asynchronous
  133.          (gnus-group-asynchronous-p group))
  134.     (save-excursion
  135.       (set-buffer gnus-summary-buffer)
  136.       (let ((next (caadr (gnus-data-find-list article))))
  137.     (when next
  138.       (if (not (fboundp 'run-with-idle-timer))
  139.           ;; This is either an older Emacs or XEmacs, so we
  140.           ;; do this, which leads to slightly slower article
  141.           ;; buffer display.
  142.           (gnus-async-prefetch-article group next summary)
  143.         (run-with-idle-timer
  144.          0.1 nil 'gnus-async-prefetch-article group next summary)))))))
  145.  
  146. (defun gnus-async-prefetch-article (group article summary &optional next)
  147.   "Possibly prefetch several articles starting with ARTICLE."
  148.   (if (not (gnus-buffer-live-p summary))
  149.       (gnus-async-with-semaphore
  150.        (setq gnus-async-fetch-list nil))
  151.     (when (and gnus-asynchronous
  152.            (gnus-alive-p))
  153.       (when next
  154.     (gnus-async-with-semaphore
  155.      (pop gnus-async-fetch-list)))
  156.       (let ((do-fetch next)
  157.         (do-message t)) ;(eq major-mode 'gnus-summary-mode)))
  158.     (when (and (gnus-group-asynchronous-p group)
  159.            (gnus-buffer-live-p summary)
  160.            (or (not next)
  161.                gnus-async-fetch-list))
  162.       (gnus-async-with-semaphore
  163.        (unless next
  164.          (setq do-fetch (not gnus-async-fetch-list))
  165.          ;; Nix out any outstanding requests.
  166.          (setq gnus-async-fetch-list nil)
  167.          ;; Fill in the new list.
  168.          (let ((n gnus-use-article-prefetch)
  169.            (data (gnus-data-find-list article))
  170.            d)
  171.            (while (and (setq d (pop data))
  172.                (if (numberp n)
  173.                    (natnump (decf n))
  174.                  n))
  175.          (unless (or (gnus-async-prefetched-article-entry
  176.                   group (setq article (gnus-data-number d)))
  177.                  (not (natnump article))
  178.                  (not (funcall gnus-async-prefetch-article-p d)))
  179.            ;; Not already fetched -- so we add it to the list.
  180.            (push article gnus-async-fetch-list)))
  181.            (setq gnus-async-fetch-list
  182.              (nreverse gnus-async-fetch-list))))
  183.  
  184.        (when do-fetch
  185.          (setq article (car gnus-async-fetch-list))))
  186.  
  187.       (when (and do-fetch article)
  188.         ;; We want to fetch some more articles.
  189.         (save-excursion
  190.           (set-buffer summary)
  191.           (let (mark)
  192.         (gnus-async-set-buffer)
  193.         (goto-char (point-max))
  194.         (setq mark (point-marker))
  195.         (let ((nnheader-callback-function
  196.                (gnus-make-async-article-function
  197.             group article mark summary next))
  198.               (nntp-server-buffer
  199.                (get-buffer gnus-async-prefetch-article-buffer)))
  200.           (when do-message
  201.             (gnus-message 9 "Prefetching article %d in group %s"
  202.                   article group))
  203.           (gnus-request-article article group))))))))))
  204.  
  205. (defun gnus-make-async-article-function (group article mark summary next)
  206.   "Return a callback function."
  207.   `(lambda (arg)
  208.      (save-excursion
  209.        (when arg
  210.      (gnus-async-set-buffer)
  211.      (gnus-async-with-semaphore
  212.       (push (list ',(intern (format "%s-%d" group article))
  213.               ,mark (set-marker (make-marker) (point-max))
  214.               ,group ,article)
  215.         gnus-async-article-alist)))
  216.        (if (not (gnus-buffer-live-p ,summary))
  217.        (gnus-async-with-semaphore
  218.         (setq gnus-async-fetch-list nil))
  219.      (gnus-async-prefetch-article ,group ,next ,summary t)))))
  220.  
  221. (defun gnus-async-unread-p (data)
  222.   "Return non-nil if DATA represents an unread article."
  223.   (gnus-data-unread-p data))
  224.  
  225. (defun gnus-async-request-fetched-article (group article buffer)
  226.   "See whether we have ARTICLE from GROUP and put it in BUFFER."
  227.   (when (numberp article)
  228.     (let ((entry (gnus-async-prefetched-article-entry group article)))
  229.       (when entry
  230.     (save-excursion
  231.       (gnus-async-set-buffer)
  232.       (copy-to-buffer buffer (cadr entry) (caddr entry))
  233.       ;; Remove the read article from the prefetch buffer.
  234.       (when (memq 'read gnus-prefetched-article-deletion-strategy)
  235.         (gnus-async-delete-prefected-entry entry))
  236.       t)))))
  237.  
  238. (defun gnus-async-delete-prefected-entry (entry)
  239.   "Delete ENTRY from buffer and alist."
  240.   (ignore-errors
  241.     (delete-region (cadr entry) (caddr entry))
  242.     (set-marker (cadr entry) nil)
  243.     (set-marker (caddr entry) nil))
  244.   (gnus-async-with-semaphore
  245.    (setq gnus-async-article-alist
  246.      (delq entry gnus-async-article-alist))))
  247.  
  248. (defun gnus-async-prefetch-remove-group (group)
  249.   "Remove all articles belonging to GROUP from the prefetch buffer."
  250.   (when (and (gnus-group-asynchronous-p group)
  251.          (memq 'exit gnus-prefetched-article-deletion-strategy))
  252.     (let ((alist gnus-async-article-alist))
  253.       (save-excursion
  254.     (gnus-async-set-buffer)
  255.     (while alist
  256.       (when (equal group (nth 3 (car alist)))
  257.         (gnus-async-delete-prefected-entry (car alist)))
  258.       (pop alist))))))
  259.  
  260. (defun gnus-async-prefetched-article-entry (group article)
  261.   "Return the entry for ARTICLE in GROUP iff it has been prefetched."
  262.   (let ((entry (assq (intern (format "%s-%d" group article))
  263.              gnus-async-article-alist)))
  264.     ;; Perhaps something has emptied the buffer?
  265.     (if (and entry
  266.          (= (cadr entry) (caddr entry)))
  267.     (progn
  268.       (ignore-errors
  269.         (set-marker (cadr entry) nil)
  270.         (set-marker (caddr entry) nil))
  271.       (setq gnus-async-article-alist
  272.         (delq entry gnus-async-article-alist))
  273.       nil)
  274.       entry)))
  275.  
  276. ;;;
  277. ;;; Header prefetch
  278. ;;;
  279.  
  280. (defun gnus-async-prefetch-headers (group)
  281.   "Prefetch the headers for group GROUP."
  282.   (save-excursion
  283.     (let (unread)
  284.       (when (and gnus-use-header-prefetch
  285.          gnus-asynchronous
  286.          (gnus-group-asynchronous-p group)
  287.          (listp gnus-async-header-prefetched)
  288.          (setq unread (gnus-list-of-unread-articles group)))
  289.     ;; Mark that a fetch is in progress.
  290.     (setq gnus-async-header-prefetched t)
  291.     (nnheader-set-temp-buffer gnus-async-prefetch-headers-buffer t)
  292.     (erase-buffer)
  293.     (let ((nntp-server-buffer (current-buffer))
  294.           (nnheader-callback-function
  295.            `(lambda (arg)
  296.           (setq gnus-async-header-prefetched
  297.             ,(cons group unread)))))
  298.       (gnus-retrieve-headers unread group gnus-fetch-old-headers))))))
  299.  
  300. (defun gnus-async-retrieve-fetched-headers (articles group)
  301.   "See whether we have prefetched headers."
  302.   (when (and gnus-use-header-prefetch
  303.          (gnus-group-asynchronous-p group)
  304.          (listp gnus-async-header-prefetched)
  305.          (equal group (car gnus-async-header-prefetched))
  306.          (equal articles (cdr gnus-async-header-prefetched)))
  307.     (save-excursion
  308.       (nnheader-set-temp-buffer gnus-async-prefetch-headers-buffer t)
  309.       (nntp-decode-text)
  310.       (copy-to-buffer nntp-server-buffer (point-min) (point-max))
  311.       (erase-buffer)
  312.       (setq gnus-async-header-prefetched nil)
  313.       t)))
  314.  
  315. (provide 'gnus-async)
  316.  
  317. ;;; gnus-async.el ends here
  318.